# TODO: Add comment
# 
# Author: guochun
###############################################################################


minicontrast.weighted=function (observed, theoretical, startpar, ..., ctrl = list(q = 1/4, 
				p = 2, rmin = NULL, rmax = NULL), fvlab = list(label = NULL, 
				desc = "minimum contrast fit"), explain = list(dataname = NULL, 
				modelname = NULL, fname = NULL), low.weight=FALSE) 
{
	verifyclass(observed, "fv")
	stopifnot(is.function(theoretical))
	if (!any("par" %in% names(formals(theoretical)))) 
		stop(paste("Theoretical function does not include an argument called", 
						sQuote("par")))
	ctrl <- resolve.defaults(ctrl, list(q = 1/4, p = 2, rmin = NULL, 
					rmax = NULL))
	fvlab <- resolve.defaults(fvlab, list(label = NULL, desc = "minimum contrast fit"))
	explain <- resolve.defaults(explain, list(dataname = NULL, 
					modelname = NULL, fname = NULL))
	rmin <- ctrl$rmin
	rmax <- ctrl$rmax
	if (!is.null(rmin) && !is.null(rmax)) 
		stopifnot(rmin < rmax && rmin >= 0)
	else {
		alim <- attr(observed, "alim")
		if (is.null(rmin)) 
			rmin <- alim[1]
		if (is.null(rmax)) 
			rmax <- alim[2]
	}
	argu <- fvnames(observed, ".x")
	rvals <- observed[[argu]]
	valu <- fvnames(observed, ".y")
	obs <- observed[[valu]]
	if (max(rvals) < rmax) 
		stop(paste("rmax=", signif(rmax, 4), "exceeds the range of available data", 
						"= [", signif(min(rvals), 4), ",", signif(max(rvals), 
								4), "]"))
	sub <- (rvals >= rmin) & (rvals <= rmax)
	rvals <- rvals[sub]
	obs <- obs[sub]
	if (!all(ok <- is.finite(obs))) {
		whinge <- paste("Some values of the empirical function", 
				sQuote(explain$fname), "were infinite or NA.")
		iMAX <- max(which(ok))
		iMIN <- min(which(!ok)) + 1
		if (iMAX > iMIN && all(ok[iMIN:iMAX])) {
			rmin <- rvals[iMIN]
			rmax <- rvals[iMAX]
			obs <- obs[iMIN:iMAX]
			rvals <- rvals[iMIN:iMAX]
			sub[sub] <- ok
			warning(paste(whinge, "Range of r values was reset to", 
							prange(c(rmin, rmax))), call. = FALSE)
		}
		else stop(paste(whinge, "Please choose a narrower range [rmin, rmax]"), 
					call. = FALSE)
	}
	obsq <- obs^(ctrl$q)
	if(low.weight){
		weights=exp(-seq(1,15,length.out=length(obsq)))
		#weights=weights/sum(weights)
	}
	objective <- function(par, obsq, theoretical, rvals, qq, 
			pp, rmin, rmax, low.weight,weights, ...) {
		theo <- theoretical(par = par, rvals, ...)
		if (!is.vector(theo) || !is.numeric(theo)) 
			stop("theoretical function did not return a numeric vector")
		if (length(theo) != length(obs)) 
			stop("theoretical function did not return the correct number of values")
		discrep <- (abs(theo^qq - obsq))^pp
		if(low.weight){
			discrep=discrep*weights
		}
		return(sum(discrep))
	}
	minimum <- optim(startpar, fn = objective, obsq = obsq, theoretical = theoretical, 
			rvals = rvals, qq = ctrl$q, pp = ctrl$p, rmin = rmin, 
			rmax = rmax, low.weight=low.weight, weights=weights, ...)
	fittheo <- theoretical(minimum$par, rvals, ...)
	label <- fvlab$label
	desc <- fvlab$desc
	if (is.null(label)) 
		label <- paste("fit(", argu, ")", collapse = "")
	fitfv <- bind.fv(observed[sub, ], data.frame(fit = fittheo), 
			label, desc)
	result <- list(par = minimum$par, fit = fitfv, opt = minimum, 
			ctrl = list(p = ctrl$p, q = ctrl$q, rmin = rmin, rmax = rmax), 
			info = explain)
	class(result) <- c("minconfit", class(result))
	return(result)
}

